home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / olectrls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  62.1 KB  |  2,248 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1996,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit OleCtrls;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Windows, Messages, ActiveX, SysUtils, Classes, Controls, Forms,
  17.   Menus, Graphics, ComObj, AxCtrls;
  18.  
  19. type
  20.  
  21.   TOleControl = class;
  22.  
  23.   TEventDispatch = class(TObject, IUnknown, IDispatch)
  24.   private
  25.     FControl: TOleControl;
  26.     { IUnknown }
  27.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  28.     function _AddRef: Integer; stdcall;
  29.     function _Release: Integer; stdcall;
  30.     { IDispatch }
  31.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  32.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  33.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  34.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  35.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  36.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  37.   public
  38.     constructor Create(Control: TOleControl);
  39.   end;
  40.  
  41.   TOleEnum = type Smallint;
  42.  
  43.   TEnumValue = record
  44.     Value: Longint;
  45.     Ident: string;
  46.   end;
  47.  
  48.   PEnumValueList = ^TEnumValueList;
  49.   TEnumValueList = array[0..32767] of TEnumValue;
  50.  
  51.   TEnumPropDesc = class
  52.   private
  53.     FDispID: Integer;
  54.     FValueCount: Integer;
  55.     FValues: PEnumValueList;
  56.   public
  57.     constructor Create(DispID, ValueCount: Integer;
  58.       const TypeInfo: ITypeInfo);
  59.     destructor Destroy; override;
  60.     procedure GetStrings(Proc: TGetStrProc);
  61.     function StringToValue(const S: string): Integer;
  62.     function ValueToString(V: Integer): string;
  63.   end;
  64.  
  65.   PControlData = ^TControlData;
  66.   TControlData = record
  67.     ClassID: TGUID;
  68.     EventIID: TGUID;
  69.     EventCount: Longint;
  70.     EventDispIDs: Pointer;
  71.     LicenseKey: Pointer;
  72.     Flags: Integer;
  73.     Version: Integer;
  74.     FontCount: Integer;
  75.     FontIDs: PDispIDList;
  76.     InstanceCount: Integer;
  77.     EnumPropDescs: TList;
  78.   end;
  79.  
  80.   TOleControl = class(TWinControl, IUnknown, IOleClientSite,
  81.     IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch,
  82.     IPropertyNotifySink, ISimpleFrameSite)
  83.   private
  84.     FControlData: PControlData;
  85.     FRefCount: Longint;
  86.     FEventDispatch: TEventDispatch;
  87.     FObjectData: HGlobal;
  88.     FOleObject: IOleObject;
  89.     FPersistStream: IPersistStreamInit;
  90.     FOleControl: IOleControl;
  91.     FControlDispatch: IDispatch;
  92.     FPropBrowsing: IPerPropertyBrowsing;
  93.     FOleInPlaceObject: IOleInPlaceObject;
  94.     FOleInPlaceActiveObject: IOleInPlaceActiveObject;
  95.     FPropConnection: Longint;
  96.     FEventsConnection: Longint;
  97.     FMiscStatus: Longint;
  98.     FFonts: TList;
  99. //    FPictures: TList;
  100.     FUpdatingColor: Boolean;
  101.     FUpdatingFont: Boolean;
  102.     FUpdatingEnabled: Boolean;
  103.     { IUnknown }
  104.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  105.     function _AddRef: Integer; stdcall;
  106.     function _Release: Integer; stdcall;
  107.     { IOleClientSite }
  108.     function SaveObject: HResult; stdcall;
  109.     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  110.       out mk: IMoniker): HResult; stdcall;
  111.     function GetContainer(out container: IOleContainer): HResult; stdcall;
  112.     function ShowObject: HResult; stdcall;
  113.     function OnShowWindow(fShow: BOOL): HResult; stdcall;
  114.     function RequestNewObjectLayout: HResult; stdcall;
  115.     { IOleControlSite }
  116.     function OnControlInfoChanged: HResult; stdcall;
  117.     function LockInPlaceActive(fLock: BOOL): HResult; stdcall;
  118.     function GetExtendedControl(out disp: IDispatch): HResult; stdcall;
  119.     function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
  120.       flags: Longint): HResult; stdcall;
  121.     function IOleControlSite.TranslateAccelerator = OleControlSite_TranslateAccelerator;
  122.     function OleControlSite_TranslateAccelerator(msg: PMsg;
  123.       grfModifiers: Longint): HResult; stdcall;
  124.     function OnFocus(fGotFocus: BOOL): HResult; stdcall;
  125.     function ShowPropertyFrame: HResult; stdcall;
  126.     { IOleWindow }
  127.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  128.     { IOleInPlaceSite }
  129.     function IOleInPlaceSite.GetWindow = OleInPlaceSite_GetWindow;
  130.     function OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; stdcall;
  131.     function CanInPlaceActivate: HResult; stdcall;
  132.     function OnInPlaceActivate: HResult; stdcall;
  133.     function OnUIActivate: HResult; stdcall;
  134.     function GetWindowContext(out frame: IOleInPlaceFrame;
  135.       out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
  136.       out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
  137.       stdcall;
  138.     function Scroll(scrollExtent: TPoint): HResult; stdcall;
  139.     function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall;
  140.     function OnInPlaceDeactivate: HResult; stdcall;
  141.     function DiscardUndoState: HResult; stdcall;
  142.     function DeactivateAndUndo: HResult; stdcall;
  143.     function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall;
  144.     { IOleInPlaceUIWindow }
  145.     function GetBorder(out rectBorder: TRect): HResult; stdcall;
  146.     function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
  147.     function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
  148.     function SetActiveObject(const activeObject: IOleInPlaceActiveObject;
  149.       pszObjName: POleStr): HResult; stdcall;
  150.     { IOleInPlaceFrame }
  151.     function IOleInPlaceFrame.GetWindow = OleInPlaceFrame_GetWindow;
  152.     function OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; stdcall;
  153.     function InsertMenus(hmenuShared: HMenu;
  154.       var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
  155.     function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  156.       hwndActiveObject: HWnd): HResult; stdcall;
  157.     function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
  158.     function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
  159.     function EnableModeless(fEnable: BOOL): HResult; stdcall;
  160.     function IOleInPlaceFrame.TranslateAccelerator = OleInPlaceFrame_TranslateAccelerator;
  161.     function OleInPlaceFrame_TranslateAccelerator(var msg: TMsg;
  162.       wID: Word): HResult; stdcall;
  163.     { IDispatch }
  164.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  165.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  166.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  167.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  168.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  169.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  170.     { IPropertyNotifySink }
  171.     function OnChanged(dispid: TDispID): HResult; stdcall;
  172.     function OnRequestEdit(dispid: TDispID): HResult; stdcall;
  173.     { ISimpleFrameSite }
  174.     function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  175.       out res: Integer; out Cookie: Longint): HResult; stdcall;
  176.     function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  177.       out res: Integer; Cookie: Longint): HResult; stdcall;
  178.     { TOleControl }
  179.     procedure CreateControl;
  180.     procedure CreateEnumPropDescs;
  181.     procedure CreateInstance;
  182.     procedure CreateStorage;
  183.     procedure DesignModified;
  184.     procedure DestroyControl;
  185.     procedure DestroyEnumPropDescs;
  186.     procedure DestroyStorage;
  187.     procedure GetEventMethod(DispID: TDispID; var Method: TMethod);
  188.     function GetMainMenu: TMainMenu;
  189.     function GetOleObject: Variant;
  190.     procedure HookControlWndProc;
  191.     procedure InvokeEvent(DispID: TDispID; var Params: TDispParams);
  192.     procedure ReadData(Stream: TStream);
  193.     procedure SetUIActive(Active: Boolean);
  194.     procedure StandardEvent(DispID: TDispID; var Params: TDispParams);
  195.     procedure WriteData(Stream: TStream);
  196.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  197.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  198.     procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE;
  199.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  200.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  201.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  202.     procedure CMDialogKey(var Message: TMessage); message CM_DIALOGKEY;
  203.     procedure CMUIActivate(var Message: TMessage); message CM_UIACTIVATE;
  204.     procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE;
  205.   protected
  206.     FEvents: Integer;
  207.     procedure CreateWnd; override;
  208.     procedure DefaultHandler(var Message); override;
  209.     procedure DefineProperties(Filer: TFiler); override;
  210.     procedure DestroyWindowHandle; override;
  211.     function GetColorProp(Index: Integer): TColor;
  212.     function GetTColorProp(Index: Integer): TColor;
  213.     function GetCurrencyProp(Index: Integer): Currency;
  214.     function GetDoubleProp(Index: Integer): Double;
  215.     function GetIDispatchProp(Index: Integer): IDispatch;
  216.     function GetIntegerProp(Index: Integer): Integer;
  217.     function GetWordBoolProp(Index: Integer): WordBool;
  218.     function GetTDateTimeProp(Index: Integer): TDateTime;
  219.     function GetTFontProp(Index: Integer): TFont;
  220.     function GetOleEnumProp(Index: Integer): TOleEnum;
  221.     function GetTOleEnumProp(Index: Integer): TOleEnum;
  222.     procedure GetProperty(Index: Integer; var Value: TVarData);
  223.     function GetSingleProp(Index: Integer): Single;
  224.     function GetSmallintProp(Index: Integer): Smallint;
  225.     function GetStringProp(Index: Integer): string;
  226.     function GetVariantProp(Index: Integer): Variant;
  227.     function GetWideStringProp(Index: Integer): WideString;
  228.     procedure InitControlData; virtual; abstract;
  229.     procedure InitControlInterface(const Obj: IUnknown); virtual;
  230.     procedure InvokeMethod(const DispInfo; Result: Pointer);
  231.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  232.     procedure SetColorProp(Index: Integer; Value: TColor);
  233.     procedure SetTColorProp(Index: Integer; Value: TColor);
  234.     procedure SetCurrencyProp(Index: Integer; Value: Currency);
  235.     procedure SetDoubleProp(Index: Integer; Value: Double);
  236.     procedure SetIDispatchProp(Index: Integer; const Value: IDispatch);
  237.     procedure SetIntegerProp(Index: Integer; Value: Integer);
  238.     procedure SetName(const Value: TComponentName); override;
  239.     procedure SetWordBoolProp(Index: Integer; Value: WordBool);
  240.     procedure SetTDateTimeProp(Index: Integer; Value: TDateTime);
  241.     procedure SetOleEnumProp(Index: Integer; Value: TOleEnum);
  242.     procedure SetTOleEnumProp(Index: Integer; Value: TOleEnum);
  243.     procedure SetProperty(Index: Integer; const Value: TVarData);
  244.     procedure SetSingleProp(Index: Integer; Value: Single);
  245.     procedure SetSmallintProp(Index: Integer; Value: Smallint);
  246.     procedure SetStringProp(Index: Integer; const Value: string);
  247.     procedure SetTFontProp(Index: Integer; const Value: TFont);
  248.     procedure SetVariantProp(Index: Integer; const Value: Variant);
  249.     procedure SetWideStringProp(Index: Integer; const Value: WideString);
  250.     procedure WndProc(var Message: TMessage); override;
  251.     property ControlData: PControlData read FControlData write FControlData;
  252.   public
  253.     constructor Create(AOwner: TComponent); override;
  254.     destructor Destroy; override;
  255.     procedure BrowseProperties;
  256.     procedure DoObjectVerb(Verb: Integer);
  257.     function GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
  258.     function GetHelpContext(Member: string; var HelpCtx: Integer;
  259.       var HelpFile: string): Boolean;
  260.     procedure GetObjectVerbs(List: TStrings);
  261.     function GetPropDisplayString(DispID: Integer): string;
  262.     procedure GetPropDisplayStrings(DispID: Integer; List: TStrings);
  263.     function IsCustomProperty(DispID: Integer): Boolean;
  264.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  265.     procedure SetPropDisplayString(DispID: Integer; const Value: string);
  266.     procedure ShowAboutBox;
  267.     property OleObject: Variant read GetOleObject;
  268.     property TabStop default True;
  269.   end;
  270.  
  271.   EOleCtrlError = class(Exception);
  272.  
  273. function FontToOleFont(Font: TFont): Variant;
  274. procedure OleFontToFont(const OleFont: Variant; Font: TFont);
  275.  
  276. implementation
  277.  
  278. uses OleConst;
  279.  
  280. const
  281.   OCM_BASE = $2000;
  282.  
  283. { Control flags }
  284.  
  285. const
  286.   cfBackColor = $00000001;
  287.   cfForeColor = $00000002;
  288.   cfFont      = $00000004;
  289.   cfEnabled   = $00000008;
  290.   cfCaption   = $00000010;
  291.   cfText      = $00000020;
  292.  
  293. const
  294.   MaxDispArgs = 32;
  295.  
  296. type
  297.  
  298.   PDispInfo = ^TDispInfo;
  299.   TDispInfo = packed record
  300.     DispID: TDispID;
  301.     ResType: Byte;
  302.     CallDesc: TCallDesc;
  303.   end;
  304.  
  305.   TArgKind = (akDWord, akSingle, akDouble);
  306.  
  307.   PEventArg = ^TEventArg;
  308.   TEventArg = record
  309.     Kind: TArgKind;
  310.     Data: array[0..1] of Integer;
  311.   end;
  312.  
  313.   TEventInfo = record
  314.     Method: TMethod;
  315.     Sender: TObject;
  316.     ArgCount: Integer;
  317.     Args: array[0..MaxDispArgs - 1] of TEventArg;
  318.   end;
  319.  
  320. { Connect an IConnectionPoint interface }
  321.  
  322. procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
  323.   const Sink: IUnknown; var Connection: Longint);
  324. var
  325.   CPC: IConnectionPointContainer;
  326.   CP: IConnectionPoint;
  327. begin
  328.   Connection := 0;
  329.   if Source.QueryInterface(IConnectionPointContainer, CPC) >= 0 then
  330.     if CPC.FindConnectionPoint(IID, CP) >= 0 then
  331.       CP.Advise(Sink, Connection);
  332. end;
  333.  
  334. { Disconnect an IConnectionPoint interface }
  335.  
  336. procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
  337.   var Connection: Longint);
  338. var
  339.   CPC: IConnectionPointContainer;
  340.   CP: IConnectionPoint;
  341. begin
  342.   if Connection <> 0 then
  343.     if Source.QueryInterface(IConnectionPointContainer, CPC) >= 0 then
  344.       if CPC.FindConnectionPoint(IID, CP) >= 0 then
  345.         if CP.Unadvise(Connection) >= 0 then Connection := 0;
  346. end;
  347.  
  348. function FontToOleFont(Font: TFont): Variant;
  349. var
  350.   Temp: IFontDisp;
  351. begin
  352.   GetOleFont(Font, Temp);
  353.   Result := Temp;
  354. end;
  355.  
  356. procedure OleFontToFont(const OleFont: Variant; Font: TFont);
  357. begin
  358.   SetOleFont(Font, IUnknown(OleFont) as IFontDisp);
  359. end;
  360.  
  361. function StringToVarOleStr(const S: string): Variant;
  362. begin
  363.   VarClear(Result);
  364.   TVarData(Result).VOleStr := StringToOleStr(S);
  365.   TVarData(Result).VType := varOleStr;
  366. end;
  367.  
  368. { TEventDispatch }
  369.  
  370. constructor TEventDispatch.Create(Control: TOleControl);
  371. begin
  372.   FControl := Control;
  373. end;
  374.  
  375. { TEventDispatch.IUnknown }
  376.  
  377. function TEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
  378. begin
  379.   if GetInterface(IID, Obj) then
  380.   begin
  381.     Result := S_OK;
  382.     Exit;
  383.   end;
  384.   if IsEqualIID(IID, FControl.FControlData^.EventIID) then
  385.   begin
  386.     GetInterface(IDispatch, Obj);
  387.     Result := S_OK;
  388.     Exit;
  389.   end;
  390.   Result := E_NOINTERFACE;
  391. end;
  392.  
  393. function TEventDispatch._AddRef: Integer;
  394. begin
  395.   Result := FControl._AddRef;
  396. end;
  397.  
  398. function TEventDispatch._Release: Integer;
  399. begin
  400.   Result := FControl._Release;
  401. end;
  402.  
  403. { TEventDispatch.IDispatch }
  404.  
  405. function TEventDispatch.GetTypeInfoCount(out Count: Integer): HResult;
  406. begin
  407.   Count := 0;
  408.   Result := S_OK;
  409. end;
  410.  
  411. function TEventDispatch.GetTypeInfo(Index, LocaleID: Integer;
  412.   out TypeInfo): HResult;
  413. begin
  414.   Pointer(TypeInfo) := nil;
  415.   Result := E_NOTIMPL;
  416. end;
  417.  
  418. function TEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  419.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  420. begin
  421.   Result := E_NOTIMPL;
  422. end;
  423.  
  424. function TEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
  425.   LocaleID: Integer; Flags: Word; var Params;
  426.   VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  427. begin
  428.   if (DispID >= DISPID_MOUSEUP) and (DispID <= DISPID_CLICK) then
  429.     FControl.StandardEvent(DispID, TDispParams(Params)) else
  430.     FControl.InvokeEvent(DispID, TDispParams(Params));
  431.   Result := S_OK;
  432. end;
  433.  
  434. { TEnumPropDesc }
  435.  
  436. constructor TEnumPropDesc.Create(DispID, ValueCount: Integer;
  437.   const TypeInfo: ITypeInfo);
  438. var
  439.   I: Integer;
  440.   VarDesc: PVarDesc;
  441.   Name: WideString;
  442. begin
  443.   FDispID := DispID;
  444.   FValueCount := ValueCount;
  445.   FValues := AllocMem(ValueCount * SizeOf(TEnumValue));
  446.   for I := 0 to ValueCount - 1 do
  447.   begin
  448.     OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
  449.     try
  450.       OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @Name,
  451.         nil, nil, nil));
  452.       with FValues^[I] do
  453.       begin
  454.         Value := TVarData(VarDesc^.lpVarValue^).VInteger;
  455.         Ident := Name;
  456.         while (Length(Ident) > 1) and (Ident[1] = '_') do
  457.           Delete(Ident, 1, 1);
  458.       end;
  459.     finally
  460.       TypeInfo.ReleaseVarDesc(VarDesc);
  461.     end;
  462.   end;
  463. end;
  464.  
  465. destructor TEnumPropDesc.Destroy;
  466. begin
  467.   if FValues <> nil then
  468.   begin
  469.     Finalize(FValues^[0], FValueCount);
  470.     FreeMem(FValues, FValueCount * SizeOf(TEnumValue));
  471.   end;
  472. end;
  473.  
  474. procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc);
  475. var
  476.   I: Integer;
  477. begin
  478.   for I := 0 to FValueCount - 1 do
  479.     with FValues^[I] do Proc(Format('%d - %s', [Value, Ident]));
  480. end;
  481.  
  482. function TEnumPropDesc.StringToValue(const S: string): Integer;
  483. var
  484.   I: Integer;
  485. begin
  486.   I := 1;
  487.   while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I);
  488.   if I > 1 then
  489.   begin
  490.     Result := StrToInt(Copy(S, 1, I - 1));
  491.     for I := 0 to FValueCount - 1 do
  492.       if Result = FValues^[I].Value then Exit;
  493.   end else
  494.     for I := 0 to FValueCount - 1 do
  495.       with FValues^[I] do
  496.         if AnsiCompareText(S, Ident) = 0 then
  497.         begin
  498.           Result := Value;
  499.           Exit;
  500.         end;
  501.   raise EOleError.CreateFmt(SBadPropValue, [S]);
  502. end;
  503.  
  504. function TEnumPropDesc.ValueToString(V: Integer): string;
  505. var
  506.   I: Integer;
  507. begin
  508.   for I := 0 to FValueCount - 1 do
  509.     with FValues^[I] do
  510.       if V = Value then
  511.       begin
  512.         Result := Format('%d - %s', [Value, Ident]);
  513.         Exit;
  514.       end;
  515.   Result := IntToStr(V);
  516. end;
  517.  
  518. { TOleControl }
  519.  
  520. constructor TOleControl.Create(AOwner: TComponent);
  521. var
  522.   I, W, H: Integer;
  523.   Extent: TPoint;
  524. begin
  525.   inherited Create(AOwner);
  526.   Include(FComponentStyle, csCheckPropAvail);
  527.   InitControlData;
  528.   Inc(FControlData^.InstanceCount);
  529.   if FControlData^.FontCount > 0 then
  530.   begin
  531.     FFonts := TList.Create;
  532.     FFonts.Count := FControlData^.FontCount;
  533.     for I := 0 to FFonts.Count-1 do
  534.       FFonts[I] := TFont.Create;
  535.   end;
  536.   FEventDispatch := TEventDispatch.Create(Self);
  537.   CreateInstance;
  538.   InitControlInterface(FOleObject);
  539.   OleCheck(FOleObject.SetClientSite(Self));
  540.   OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream));
  541.   OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus));
  542.   OleCheck(FOleObject.GetExtent(DVASPECT_CONTENT, Extent));
  543.   W := MulDiv(Extent.X, Screen.PixelsPerInch, 2540);
  544.   H := MulDiv(Extent.Y, Screen.PixelsPerInch, 2540);
  545.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
  546.   begin
  547.     Visible := False;
  548.     if W > 32 then W := 32;
  549.     if H > 32 then H := 32;
  550.   end;
  551.   inherited SetBounds(Left, Top, W, H);
  552.   if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
  553.     ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else
  554.     ControlStyle := [csDoubleClicks, csNoStdEvents];
  555.   TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or
  556.     OLEMISC_NOUIACTIVATE) = 0;
  557. end;
  558.  
  559. destructor TOleControl.Destroy;
  560. var
  561.   I: Integer;
  562. begin
  563.   if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
  564.   DestroyControl;
  565.   DestroyStorage;
  566.   FPersistStream := nil;
  567.   if FOleObject <> nil then FOleObject.SetClientSite(nil);
  568.   FOleObject := nil;
  569.   FEventDispatch.Free;
  570.   if FFonts <> nil then
  571.   begin
  572.     for I := 0 to FFonts.Count-1 do
  573.       TObject(FFonts[I]).Free;
  574.     FFonts.Free;
  575.   end;
  576.   Dec(FControlData^.InstanceCount);
  577.   if FControlData^.InstanceCount = 0 then DestroyEnumPropDescs;
  578.   inherited Destroy;
  579. end;
  580.  
  581. procedure TOleControl.BrowseProperties;
  582. begin
  583.   DoObjectVerb(OLEIVERB_PROPERTIES);
  584. end;
  585.  
  586. procedure TOleControl.CreateControl;
  587. var
  588.   Stream: IStream;
  589. begin
  590.   if FOleControl = nil then
  591.     try
  592.       if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else
  593.       begin
  594.         OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
  595.         OleCheck(FPersistStream.Load(Stream));
  596.         DestroyStorage;
  597.       end;
  598.       OleCheck(FOleObject.QueryInterface(IOleControl, FOleControl));
  599.       OleCheck(FOleObject.QueryInterface(IDispatch, FControlDispatch));
  600.       FOleObject.QueryInterface(IPerPropertyBrowsing, FPropBrowsing);
  601.       InterfaceConnect(FOleObject, IPropertyNotifySink,
  602.         Self, FPropConnection);
  603.       InterfaceConnect(FOleObject, FControlData^.EventIID,
  604.         FEventDispatch, FEventsConnection);
  605.       if FControlData^.Flags and cfBackColor <> 0 then
  606.         OnChanged(DISPID_BACKCOLOR);
  607.       if FControlData^.Flags and cfEnabled <> 0 then
  608.         OnChanged(DISPID_ENABLED);
  609.       if FControlData^.Flags and cfFont <> 0 then
  610.         OnChanged(DISPID_FONT);
  611.       if FControlData^.Flags and cfForeColor <> 0 then
  612.         OnChanged(DISPID_FORECOLOR);
  613.       FOleObject.SetExtent(DVASPECT_CONTENT, Point(
  614.         MulDiv(Width, 2540, Screen.PixelsPerInch),
  615.         MulDiv(Height, 2540, Screen.PixelsPerInch)));
  616.     except
  617.       DestroyControl;
  618.       raise;
  619.     end;
  620. end;
  621.  
  622. procedure TOleControl.CreateEnumPropDescs;
  623. var
  624.   I: Integer;
  625.   TypeInfo, RefInfo: ITypeInfo;
  626.   TypeAttr, RefAttr: PTypeAttr;
  627.   VarDesc: PVarDesc;
  628. begin
  629.   CreateControl;
  630.   FControlData^.EnumPropDescs := TList.Create;
  631.   try
  632.     OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo));
  633.     OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
  634.     try
  635.       for I := 0 to TypeAttr^.cVars - 1 do
  636.       begin
  637.         OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
  638.         try
  639.           if VarDesc^.elemdescVar.tdesc.vt = VT_USERDEFINED then
  640.           begin
  641.             OleCheck(TypeInfo.GetRefTypeInfo(
  642.               VarDesc^.elemdescVar.tdesc.hreftype, RefInfo));
  643.             OleCheck(RefInfo.GetTypeAttr(RefAttr));
  644.             try
  645.               if RefAttr^.typekind = TKIND_ENUM then
  646.                 FControlData^.EnumPropDescs.Expand.Add(
  647.                   TEnumPropDesc.Create(VarDesc^.memid,
  648.                   RefAttr^.cVars, RefInfo));
  649.             finally
  650.               RefInfo.ReleaseTypeAttr(RefAttr);
  651.             end;
  652.             RefInfo := nil;
  653.           end;
  654.         finally
  655.           TypeInfo.ReleaseVarDesc(VarDesc);
  656.         end;
  657.       end;
  658.     finally
  659.       TypeInfo.ReleaseTypeAttr(TypeAttr);
  660.     end;
  661.   except
  662.     DestroyEnumPropDescs;
  663.     raise;
  664.   end;
  665. end;
  666.  
  667. procedure TOleControl.CreateInstance;
  668. var
  669.   ClassFactory2: IClassFactory2;
  670.   LicKeyStr: WideString;
  671.  
  672.   procedure LicenseCheck(Status: HResult; const Ident: string);
  673.   begin
  674.     if Status = CLASS_E_NOTLICENSED then
  675.       raise EOleError.CreateFmt(Ident, [ClassName]);
  676.     OleCheck(Status);
  677.   end;
  678.  
  679. begin
  680.   if not (csDesigning in ComponentState) and
  681.     (FControlData^.LicenseKey <> nil) then
  682.   begin
  683.     OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or
  684.       CLSCTX_LOCAL_SERVER, nil, IClassFactory2, ClassFactory2));
  685.     LicKeyStr := PWideChar(FControlData^.LicenseKey);
  686.     LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IOleObject,
  687.       LicKeyStr, FOleObject), SInvalidLicense);
  688.   end else
  689.     LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil,
  690.       CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject,
  691.       FOleObject), SNotLicensed);
  692. end;
  693.  
  694. procedure TOleControl.CreateStorage;
  695. var
  696.   Stream: IStream;
  697. begin
  698.   DestroyStorage;
  699.   FObjectData := GlobalAlloc(GMEM_MOVEABLE, 0);
  700.   if FObjectData = 0 then OutOfMemoryError;
  701.   try
  702.     OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
  703.     OleCheck(FPersistStream.Save(Stream, True));
  704.   except
  705.     DestroyStorage;
  706.     raise;
  707.   end;
  708. end;
  709.  
  710. procedure TOleControl.CreateWnd;
  711. begin
  712.   CreateControl;
  713.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  714.   begin
  715.     FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, Self, 0,
  716.       GetParentHandle, BoundsRect);
  717.     if FOleInPlaceObject = nil then
  718.       raise EOleError.Create(SCannotActivate);
  719.     HookControlWndProc;
  720.     if not Visible and IsWindowVisible(Handle) then
  721.       ShowWindow(Handle, SW_HIDE);
  722.   end else
  723.     inherited CreateWnd;
  724. end;
  725.  
  726. procedure TOleControl.DefaultHandler(var Message);
  727. begin
  728.   if HandleAllocated then
  729.     with TMessage(Message) do
  730.     begin
  731.       if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
  732.         Msg := Msg - (CN_BASE - OCM_BASE);
  733.       if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then
  734.       begin
  735.         Result := CallWindowProc(DefWndProc, Handle, Msg, WParam, LParam);
  736.         Exit;
  737.       end;
  738.     end;
  739.   inherited DefaultHandler(Message);
  740. end;
  741.  
  742. procedure TOleControl.DefineProperties(Filer: TFiler);
  743. begin
  744.   inherited DefineProperties(Filer);
  745.   Filer.DefineBinaryProperty('ControlData', ReadData, WriteData, FOleObject <> nil);
  746. end;
  747.  
  748. procedure TOleControl.DesignModified;
  749. var
  750.   Form: TCustomForm;
  751. begin
  752.   Form := GetParentForm(Self);
  753.   if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  754. end;
  755.  
  756. procedure TOleControl.DestroyControl;
  757. begin
  758.   InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection);
  759.   InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection);
  760.   FPropBrowsing := nil;
  761.   FControlDispatch := nil;
  762.   FOleControl := nil;
  763. end;
  764.  
  765. procedure TOleControl.DestroyEnumPropDescs;
  766. var
  767.   I: Integer;
  768. begin
  769.   with FControlData^ do
  770.     if EnumPropDescs <> nil then
  771.     begin
  772.       for I := 0 to EnumPropDescs.Count - 1 do
  773.         TEnumPropDesc(EnumPropDescs[I]).Free;
  774.       EnumPropDescs.Free;
  775.       EnumPropDescs := nil;
  776.     end;
  777. end;
  778.  
  779. procedure TOleControl.DestroyStorage;
  780. begin
  781.   if FObjectData <> 0 then
  782.   begin
  783.     GlobalFree(FObjectData);
  784.     FObjectData := 0;
  785.   end;
  786. end;
  787.  
  788. procedure TOleControl.DestroyWindowHandle;
  789. begin
  790.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  791.   begin
  792.     SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(DefWndProc));
  793.     if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
  794.     WindowHandle := 0;
  795.   end else
  796.     inherited DestroyWindowHandle;
  797. end;
  798.  
  799. procedure TOleControl.DoObjectVerb(Verb: Integer);
  800. var
  801.   ActiveWindow: HWnd;
  802.   WindowList: Pointer;
  803. begin
  804.   CreateControl;
  805.   ActiveWindow := GetActiveWindow;
  806.   WindowList := DisableTaskWindows(0);
  807.   try
  808.     OleCheck(FOleObject.DoVerb(Verb, nil, Self, 0,
  809.       GetParentHandle, BoundsRect));
  810.   finally
  811.     EnableTaskWindows(WindowList);
  812.     SetActiveWindow(ActiveWindow);
  813.   end;
  814.   if FPersistStream.IsDirty <> S_FALSE then DesignModified;
  815. end;
  816.  
  817. function TOleControl.GetColorProp(Index: Integer): TColor;
  818. begin
  819.   Result := GetIntegerProp(Index);
  820. end;
  821.  
  822. function TOleControl.GetTColorProp(Index: Integer): TColor;
  823. begin
  824.   Result := GetIntegerProp(Index);
  825. end;
  826.  
  827. function TOleControl.GetCurrencyProp(Index: Integer): Currency;
  828. var
  829.   Temp: TVarData;
  830. begin
  831.   GetProperty(Index, Temp);
  832.   Result := Temp.VCurrency;
  833. end;
  834.  
  835. function TOleControl.GetDoubleProp(Index: Integer): Double;
  836. var
  837.   Temp: TVarData;
  838. begin
  839.   GetProperty(Index, Temp);
  840.   Result := Temp.VDouble;
  841. end;
  842.  
  843. function TOleControl.GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
  844. var
  845.   I: Integer;
  846. begin
  847.   with FControlData^ do
  848.   begin
  849.     if EnumPropDescs = nil then CreateEnumPropDescs;
  850.     for I := 0 to EnumPropDescs.Count - 1 do
  851.     begin
  852.       Result := EnumPropDescs[I];
  853.       if Result.FDispID = DispID then Exit;
  854.     end;
  855.     Result := nil;
  856.   end;
  857. end;
  858.  
  859. procedure TOleControl.GetEventMethod(DispID: TDispID; var Method: TMethod);
  860. asm
  861.         PUSH    EBX
  862.         PUSH    ESI
  863.         PUSH    EDI
  864.         MOV     EBX,EAX
  865.         MOV     ESI,[EBX].TOleControl.FControlData
  866.         MOV     EDI,[ESI].TControlData.EventCount
  867.         MOV     ESI,[ESI].TControlData.EventDispIDs
  868.         XOR     EAX,EAX
  869.         JMP     @@1
  870. @@0:    CMP     EDX,[ESI].Integer[EAX*4]
  871.         JE      @@2
  872.         INC     EAX
  873. @@1:    CMP     EAX,EDI
  874.         JNE     @@0
  875.         XOR     EAX,EAX
  876.         XOR     EDX,EDX
  877.         JMP     @@3
  878. @@2:    MOV     EDX,[EBX].TOleControl.FEvents[4][EAX*8].TMethod.Data
  879.         MOV     EAX,[EBX].TOleControl.FEvents[4][EAX*8].TMethod.Code
  880. @@3:    MOV     [ECX].TMethod.Code,EAX
  881.         MOV     [ECX].TMethod.Data,EDX
  882.         POP     EDI
  883.         POP     ESI
  884.         POP     EBX
  885. end;
  886.  
  887. procedure Exchange(var A,B); register;
  888. asm
  889.   MOV   ECX, [EDX]
  890.   XCHG  ECX, [EAX]
  891.   MOV   [EDX], ECX
  892. end;
  893.  
  894. { TOleControl.GetHelpContext:  Fetch the help file name and help context
  895.   id of the given member (property, event, or method) of the Ole Control from
  896.   the control's ITypeInfo interfaces.  GetHelpContext returns False if
  897.   the member name is not found in the control's ITypeInfo.
  898.   To obtain a help context for the entire control class, pass an empty
  899.   string as the Member name.  }
  900.  
  901. function TOleControl.GetHelpContext(Member: string;
  902.   var HelpCtx: Integer; var HelpFile: string): Boolean;
  903. var
  904.   TypeInfo: ITypeInfo;
  905.   HlpFile: TBStr;
  906.   ImplTypes, MemberID: Integer;
  907.   TypeAttr: PTypeAttr;
  908.  
  909.   function Find(const MemberStr: string; var TypeInfo: ITypeInfo): Boolean;
  910.   var
  911.     Code: HResult;
  912.     I, Flags: Integer;
  913.     RefType: HRefType;
  914.     Name: TBStr;
  915.     Temp: ITypeInfo;
  916.   begin
  917.     Result := False;
  918.     Name := StringToOleStr(Member);
  919.     try
  920.       I := 0;
  921.       while (I < ImplTypes) do
  922.       begin
  923.         OleCheck(TypeInfo.GetImplTypeFlags(I, Flags));
  924.         if Flags and (IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE) <> 0 then
  925.         begin
  926.           OleCheck(TypeInfo.GetRefTypeOfImplType(I, RefType));
  927.           OleCheck(TypeInfo.GetRefTypeInfo(RefType, Temp));
  928.           Code := Temp.GetIDsOfNames(@Name, 1, @MemberID);
  929.           if Code <> DISP_E_UNKNOWNNAME then
  930.           begin
  931.             OleCheck(Code);
  932.             Exchange(TypeInfo, Temp);
  933.             Result := True;
  934.             Break;
  935.           end;
  936.         end;
  937.         Inc(I);
  938.       end;
  939.     finally
  940.       SysFreeString(Name);
  941.     end;
  942.   end;
  943.  
  944. begin
  945.   HelpCtx := 0;
  946.   HelpFile := '';
  947.   CreateControl;
  948.   OleCheck((FOleObject as IProvideClassInfo).GetClassInfo(TypeInfo));
  949.   MemberID := MEMBERID_NIL;
  950.   if Length(Member) > 0 then
  951.   begin
  952.     OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
  953.     ImplTypes := TypeAttr.cImplTypes;
  954.     TypeInfo.ReleaseTypeAttr(TypeAttr);
  955.     Result := Find(Member, TypeInfo);
  956.     if (not Result) and (Member[Length(Member)] = '_') then
  957.     begin
  958.       Delete(Member, Length(Member)-1, 1);
  959.       Result := Find(Member, TypeInfo);
  960.     end;
  961.     if (not Result) and (Pos('On', Member) = 1) then
  962.     begin
  963.       Delete(Member, 1, 2);
  964.       Result := Find(Member, TypeInfo);
  965.     end;
  966.     if not Result then Exit;
  967.   end;
  968.   OleCheck(TypeInfo.GetDocumentation(MemberID, nil, nil, @HelpCtx, @HlpFile));
  969.   HelpFile := OleStrToString(HlpFile);
  970.   SysFreeString(HlpFile);
  971.   Result := True;
  972. end;
  973.  
  974. function TOleControl.GetIDispatchProp(Index: Integer): IDispatch;
  975. var
  976.   Temp: TVarData;
  977. begin
  978.   GetProperty(Index, Temp);
  979.   Result := IDispatch(Temp.VDispatch);
  980. end;
  981.  
  982. function TOleControl.GetIntegerProp(Index: Integer): Integer;
  983. var
  984.   Temp: TVarData;
  985. begin
  986.   GetProperty(Index, Temp);
  987.   Result := Temp.VInteger;
  988. end;
  989.  
  990. function TOleControl.GetMainMenu: TMainMenu;
  991. var
  992.   Form: TCustomForm;
  993. begin
  994.   Result := nil;
  995.   Form := GetParentForm(Self);
  996.   if Form <> nil then
  997.     if (Form is TForm) and (TForm(Form).FormStyle <> fsMDIChild) then
  998.       Result := Form.Menu
  999.     else
  1000.       if Application.MainForm <> nil then
  1001.         Result := Application.MainForm.Menu;
  1002. end;
  1003.  
  1004. procedure TOleControl.GetObjectVerbs(List: TStrings);
  1005. var
  1006.   I: Integer;
  1007.   S: string;
  1008.   EnumOleVerb: IEnumOleVerb;
  1009.   OleVerb: TOleVerb;
  1010. begin
  1011.   CreateControl;
  1012.   List.Clear;
  1013.   if FOleObject.EnumVerbs(EnumOleVerb) = 0 then
  1014.     while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and
  1015.       (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do
  1016.     begin
  1017.       S := OleVerb.lpszVerbName;
  1018.       for I := Length(S) downto 1 do if S[I] = '&' then Delete(S, I, 1);
  1019.       List.AddObject(S, TObject(OleVerb.lVerb));
  1020.     end;
  1021. end;
  1022.  
  1023. function TOleControl.GetWordBoolProp(Index: Integer): WordBool;
  1024. var
  1025.   Temp: TVarData;
  1026. begin
  1027.   GetProperty(Index, Temp);
  1028.   Result := Temp.VBoolean;
  1029. end;
  1030.  
  1031. function TOleControl.GetTDateTimeProp(Index: Integer): TDateTime;
  1032. var
  1033.   Temp: TVarData;
  1034. begin
  1035.   GetProperty(Index, Temp);
  1036.   Result := Temp.VDate;
  1037. end;
  1038.  
  1039. function TOleControl.GetTFontProp(Index: Integer): TFont;
  1040. var
  1041.   I: Integer;
  1042. begin
  1043.   Result := nil;
  1044.   for I := 0 to FFonts.Count-1 do
  1045.     if FControlData^.FontIDs^[I] = Index then
  1046.     begin
  1047.       Result := TFont(FFonts[I]);
  1048.       if Result.FontAdapter = nil then
  1049.         SetOleFont(Result, GetIDispatchProp(Index) as IFontDisp);
  1050.     end;
  1051. end;
  1052.  
  1053. function TOleControl.GetOleEnumProp(Index: Integer): TOleEnum;
  1054. begin
  1055.   Result := GetSmallintProp(Index);
  1056. end;
  1057.  
  1058. function TOleControl.GetTOleEnumProp(Index: Integer): TOleEnum;
  1059. begin
  1060.   Result := GetSmallintProp(Index);
  1061. end;
  1062.  
  1063. function TOleControl.GetOleObject: Variant;
  1064. begin
  1065.   CreateControl;
  1066.   Result := Variant(FOleObject);
  1067. end;
  1068.  
  1069. function TOleControl.GetPropDisplayString(DispID: Integer): string;
  1070. var
  1071.   S: WideString;
  1072. begin
  1073.   CreateControl;
  1074.   if (FPropBrowsing <> nil) and
  1075.     (FPropBrowsing.GetDisplayString(DispID, @S) = 0) then
  1076.     Result := S else
  1077.     Result := GetStringProp(DispID);
  1078. end;
  1079.  
  1080. procedure TOleControl.GetPropDisplayStrings(DispID: Integer; List: TStrings);
  1081. var
  1082.   Strings: TCAPOleStr;
  1083.   Cookies: TCALongint;
  1084.   I: Integer;
  1085. begin
  1086.   CreateControl;
  1087.   List.Clear;
  1088.   if (FPropBrowsing <> nil) and
  1089.     (FPropBrowsing.GetPredefinedStrings(DispID, Strings, Cookies) = 0) then
  1090.     try
  1091.       for I := 0 to Strings.cElems - 1 do
  1092.         List.AddObject(Strings.pElems^[I], TObject(Cookies.pElems^[I]));
  1093.     finally
  1094.       for I := 0 to Strings.cElems - 1 do
  1095.         CoTaskMemFree(Strings.pElems^[I]);
  1096.       CoTaskMemFree(Strings.pElems);
  1097.       CoTaskMemFree(Cookies.pElems);
  1098.     end;
  1099. end;
  1100.  
  1101. var  // init to zero, never written to
  1102.   DispParams: TDispParams = ();
  1103.  
  1104. procedure TOleControl.GetProperty(Index: Integer; var Value: TVarData);
  1105. var
  1106.   Status: HResult;
  1107.   ExcepInfo: TExcepInfo;
  1108. begin
  1109.   CreateControl;
  1110.   Value.VType := varEmpty;
  1111.   Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
  1112.     DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil);
  1113.   if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
  1114. end;
  1115.  
  1116. function TOleControl.GetSingleProp(Index: Integer): Single;
  1117. var
  1118.   Temp: TVarData;
  1119. begin
  1120.   GetProperty(Index, Temp);
  1121.   Result := Temp.VSingle;
  1122. end;
  1123.  
  1124. function TOleControl.GetSmallintProp(Index: Integer): Smallint;
  1125. var
  1126.   Temp: TVarData;
  1127. begin
  1128.   GetProperty(Index, Temp);
  1129.   Result := Temp.VSmallint;
  1130. end;
  1131.  
  1132. function TOleControl.GetStringProp(Index: Integer): string;
  1133. var
  1134.   Temp: TVarData;
  1135. begin
  1136.   GetProperty(Index, Temp);
  1137.   try
  1138.     OleStrToStrVar(Temp.VOleStr, Result);
  1139.   finally
  1140.     SysFreeString(Temp.VOleStr);
  1141.   end;
  1142. end;
  1143.  
  1144. function TOleControl.GetVariantProp(Index: Integer): Variant;
  1145. begin
  1146.   VarClear(Result);
  1147.   GetProperty(Index, TVarData(Result));
  1148. end;
  1149.  
  1150. function TOleControl.GetWideStringProp(Index: Integer): WideString;
  1151. var
  1152.   Temp: TVarData;
  1153. begin
  1154.   GetProperty(Index, Temp);
  1155.   Result := Temp.VOleStr;
  1156. end;
  1157.  
  1158. procedure TOleControl.HookControlWndProc;
  1159. var
  1160.   WndHandle: HWnd;
  1161. begin
  1162.   if (FOleInPlaceObject <> nil) and (WindowHandle = 0) then
  1163.   begin
  1164.     WndHandle := 0;
  1165.     FOleInPlaceObject.GetWindow(WndHandle);
  1166.     if WndHandle = 0 then raise EOleError.Create(SNoWindowHandle);
  1167.     WindowHandle := WndHandle;
  1168.     DefWndProc := Pointer(GetWindowLong(WindowHandle, GWL_WNDPROC));
  1169.     CreationControl := Self;
  1170.     SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(@InitWndProc));
  1171.     SendMessage(WindowHandle, WM_NULL, 0, 0);
  1172.   end;
  1173. end;
  1174.  
  1175. procedure TOleControl.InvokeEvent(DispID: TDispID; var Params: TDispParams);
  1176. type
  1177.   PVarArg = ^TVarArg;
  1178.   TVarArg = array[0..3] of Integer;
  1179. var
  1180.   EventMethod: TMethod;
  1181. begin
  1182.   GetEventMethod(DispID, EventMethod);
  1183.   if Integer(EventMethod.Code) < $10000 then Exit;
  1184.  
  1185.   try
  1186.     asm
  1187.               PUSH    EBX
  1188.               PUSH    ESI
  1189.               MOV     ESI, Params
  1190.               MOV     EBX, [ESI].TDispParams.cArgs
  1191.               TEST    EBX, EBX
  1192.               JZ      @@7
  1193.               MOV     ESI, [ESI].TDispParams.rgvarg
  1194.               MOV     EAX, EBX
  1195.               SHL     EAX, 4     // count * sizeof(TVarArg)
  1196.               XOR     EDX, EDX
  1197.               ADD     ESI, EAX   // EDI = Params.rgvarg^[ArgCount]
  1198.       @@1:    SUB     ESI, 16    // Sizeof(TVarArg)
  1199.               MOV     EAX, dword ptr [ESI]
  1200.               CMP     AX, varSingle
  1201.               JA      @@3
  1202.               JE      @@4
  1203.       @@2:    TEST    DL,DL
  1204.               JNE     @@5
  1205.               MOV     ECX, dword ptr [ESI+8]
  1206.               INC     DL
  1207.               JMP     @@6
  1208.       @@3:    CMP     AX, varDate
  1209.               JA      @@2
  1210.       @@4:    PUSH    dword ptr [ESI+12]
  1211.       @@5:    PUSH    dword ptr [ESI+8]
  1212.       @@6:    DEC     EBX
  1213.               JNE     @@1
  1214.       @@7:    MOV     EDX, Self
  1215.               MOV     EAX, EventMethod.Data
  1216.               CALL    EventMethod.Code
  1217.               POP     ESI
  1218.               POP     EBX
  1219.     end;
  1220.   except
  1221.     Application.HandleException(Self);
  1222.   end;
  1223. end;
  1224.  
  1225. procedure GetStringResult(BStr: TBStr; var Result: string);
  1226. begin
  1227.   try
  1228.     OleStrToStrVar(BStr, Result);
  1229.   finally
  1230.     SysFreeString(BStr);
  1231.   end;
  1232. end;
  1233.  
  1234. procedure TOleControl.InitControlInterface;
  1235. begin
  1236. end;
  1237.  
  1238. procedure TOleControl.InvokeMethod(const DispInfo; Result: Pointer); assembler;
  1239. asm
  1240.         PUSH    EBX
  1241.         PUSH    ESI
  1242.         PUSH    EDI
  1243.         MOV     EBX,EAX
  1244.         MOV     ESI,EDX
  1245.         MOV     EDI,ECX
  1246.         CALL    TOleControl.CreateControl
  1247.         PUSH    [ESI].TDispInfo.DispID
  1248.         MOV     ECX,ESP
  1249.         XOR     EAX,EAX
  1250.         PUSH    EAX
  1251.         PUSH    EAX
  1252.         PUSH    EAX
  1253.         PUSH    EAX
  1254.         MOV     EDX,ESP
  1255.         LEA     EAX,[EBP+16]
  1256.         CMP     [ESI].TDispInfo.ResType,varOleStr
  1257.         JE      @@1
  1258.         CMP     [ESI].TDispInfo.ResType,varVariant
  1259.         JE      @@1
  1260.         LEA     EAX,[EBP+12]
  1261. @@1:    PUSH    EAX
  1262.         PUSH    EDX
  1263.         LEA     EDX,[ESI].TDispInfo.CallDesc
  1264.         MOV     EAX,[EBX].TOleControl.FControlDispatch
  1265.         CALL    DispatchInvoke
  1266.         XOR     EAX,EAX
  1267.         MOV     AL,[ESI].TDispInfo.ResType
  1268.         JMP     @ResultTable.Pointer[EAX*4]
  1269.  
  1270. @ResultTable:
  1271.         DD      @ResEmpty
  1272.         DD      @ResNull
  1273.         DD      @ResSmallint
  1274.         DD      @ResInteger
  1275.         DD      @ResSingle
  1276.         DD      @ResDouble
  1277.         DD      @ResCurrency
  1278.         DD      @ResDate
  1279.         DD      @ResString
  1280.         DD      @ResDispatch
  1281.         DD      @ResError
  1282.         DD      @ResBoolean
  1283.         DD      @ResVariant
  1284.  
  1285. @ResSmallint:
  1286. @ResBoolean:
  1287.         MOV     AX,[ESP+8]
  1288.         MOV     [EDI],AX
  1289.         JMP     @ResDone
  1290.  
  1291. @ResString:
  1292.         MOV     EAX,[ESP+8]
  1293.         MOV     EDX,EDI
  1294.         CALL    GetStringResult
  1295.         JMP     @ResDone
  1296.  
  1297. @ResVariant:
  1298.         MOV     EAX,EDI
  1299.         CALL    VarClear
  1300.         MOV     ESI,ESP
  1301.         MOV     ECX,4
  1302.         REP     MOVSD
  1303.         JMP     @ResDone
  1304.  
  1305. @ResDouble:
  1306. @ResCurrency:
  1307. @ResDate:
  1308.         MOV     EAX,[ESP+12]
  1309.         MOV     [EDI+4],EAX
  1310.  
  1311. @ResInteger:
  1312. @ResSingle:
  1313.         MOV     EAX,[ESP+8]
  1314.         MOV     [EDI],EAX
  1315.  
  1316. @ResEmpty:
  1317. @ResNull:
  1318. @ResDispatch:
  1319. @ResError:
  1320. @ResDone:
  1321.         ADD     ESP,20
  1322.         POP     EDI
  1323.         POP     ESI
  1324.         POP     EBX
  1325. end;
  1326.  
  1327. function TOleControl.IsCustomProperty(DispID: Integer): Boolean;
  1328. begin
  1329.   Result := (FPropBrowsing <> nil) and
  1330.     (FPropBrowsing.GetDisplayString(DispID, nil) = 0);
  1331. end;
  1332.  
  1333. function TOleControl.PaletteChanged(Foreground: Boolean): Boolean;
  1334. begin
  1335.   Result := False;
  1336.   if HandleAllocated and Foreground then
  1337.     Result := CallWindowProc(DefWndProc, Handle, WM_QUERYNEWPALETTE, 0, 0) <> 0;
  1338.   if not Result then
  1339.     Result := inherited PaletteChanged(Foreground);
  1340. end;
  1341.  
  1342. procedure TOleControl.ReadData(Stream: TStream);
  1343. var
  1344.   Buffer: Pointer;
  1345. begin
  1346.   DestroyStorage;
  1347.   try
  1348.     FObjectData := GlobalAlloc(GMEM_MOVEABLE, Stream.Size);
  1349.     if FObjectData = 0 then OutOfMemoryError;
  1350.     Buffer := GlobalLock(FObjectData);
  1351.     try
  1352.       Stream.Read(Buffer^, Stream.Size);
  1353.     finally
  1354.       GlobalUnlock(FObjectData);
  1355.     end;
  1356.   except
  1357.     DestroyStorage;
  1358.   end;
  1359. end;
  1360.  
  1361. procedure TOleControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1362. begin
  1363.   if (AWidth <> Width) or (AHeight <> Height) then
  1364.     if (FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) or
  1365.       (FOleControl <> nil) and
  1366.       (FOleObject.SetExtent(DVASPECT_CONTENT, Point(
  1367.       MulDiv(AWidth, 2540, Screen.PixelsPerInch),
  1368.       MulDiv(AHeight, 2540, Screen.PixelsPerInch))) <> S_OK) then
  1369.     begin
  1370.       AWidth := Width;
  1371.       AHeight := Height;
  1372.     end;
  1373.   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  1374. end;
  1375.  
  1376. procedure TOleControl.SetColorProp(Index: Integer; Value: TColor);
  1377. begin
  1378.   SetIntegerProp(Index, Value);
  1379. end;
  1380.  
  1381. procedure TOleControl.SetTColorProp(Index: Integer; Value: TColor);
  1382. begin
  1383.   SetIntegerProp(Index, Value);
  1384. end;
  1385.  
  1386. procedure TOleControl.SetCurrencyProp(Index: Integer; Value: Currency);
  1387. var
  1388.   Temp: TVarData;
  1389. begin
  1390.   Temp.VType := varCurrency;
  1391.   Temp.VCurrency := Value;
  1392.   SetProperty(Index, Temp);
  1393. end;
  1394.  
  1395. procedure TOleControl.SetDoubleProp(Index: Integer; Value: Double);
  1396. var
  1397.   Temp: TVarData;
  1398. begin
  1399.   Temp.VType := varDouble;
  1400.   Temp.VDouble := Value;
  1401.   SetProperty(Index, Temp);
  1402. end;
  1403.  
  1404. procedure TOleControl.SetIDispatchProp(Index: Integer; const Value: IDispatch);
  1405. var
  1406.   Temp: TVarData;
  1407. begin
  1408.   Temp.VType := varDispatch;
  1409.   Temp.VDispatch := Pointer(Value);
  1410.   SetProperty(Index, Temp);
  1411. end;
  1412.  
  1413. procedure TOleControl.SetIntegerProp(Index: Integer; Value: Integer);
  1414. var
  1415.   Temp: TVarData;
  1416. begin
  1417.   Temp.VType := varInteger;
  1418.   Temp.VInteger := Value;
  1419.   SetProperty(Index, Temp);
  1420. end;
  1421.  
  1422. procedure TOleControl.SetName(const Value: TComponentName);
  1423. var
  1424.   OldName: string;
  1425.   DispID: Integer;
  1426. begin
  1427.   OldName := Name;
  1428.   inherited SetName(Value);
  1429.   if FOleControl <> nil then
  1430.   begin
  1431.     FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME);
  1432.     if FControlData^.Flags and (cfCaption or cfText) <> 0 then
  1433.     begin
  1434.       if FControlData^.Flags and cfCaption <> 0 then
  1435.         DispID := DISPID_CAPTION else
  1436.         DispID := DISPID_TEXT;
  1437.       if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value);
  1438.     end;
  1439.   end;
  1440. end;
  1441.  
  1442. procedure TOleControl.SetWordBoolProp(Index: Integer; Value: WordBool);
  1443. var
  1444.   Temp: TVarData;
  1445. begin
  1446.   Temp.VType := varBoolean;
  1447.   if Value then
  1448.     Temp.VBoolean := WordBool(-1) else
  1449.     Temp.VBoolean := WordBool(0);
  1450.   SetProperty(Index, Temp);
  1451. end;
  1452.  
  1453. procedure TOleControl.SetTDateTimeProp(Index: Integer; Value: TDateTime);
  1454. var
  1455.   Temp: TVarData;
  1456. begin
  1457.   Temp.VType := varDate;
  1458.   Temp.VDate := Value;
  1459.   SetProperty(Index, Temp);
  1460. end;
  1461.  
  1462. procedure TOleControl.SetTFontProp(Index: Integer; const Value: TFont);
  1463. var
  1464.   I: Integer;
  1465.   F: TFont;
  1466.   Temp: IFontDisp;
  1467. begin
  1468.   for I := 0 to FFonts.Count-1 do
  1469.     if FControlData^.FontIDs^[I] = Index then
  1470.     begin
  1471.       F := TFont(FFonts[I]);
  1472.       F.Assign(Value);
  1473.       if F.FontAdapter = nil then
  1474.       begin
  1475.         GetOleFont(F, Temp);
  1476.         SetIDispatchProp(Index, Temp);
  1477.       end;
  1478.     end;
  1479. end;
  1480.  
  1481. procedure TOleControl.SetOleEnumProp(Index: Integer; Value: TOleEnum);
  1482. begin
  1483.   SetSmallintProp(Index, Value);
  1484. end;
  1485.  
  1486. procedure TOleControl.SetTOleEnumProp(Index: Integer; Value: TOleEnum);
  1487. begin
  1488.   SetSmallintProp(Index, Value);
  1489. end;
  1490.  
  1491. procedure TOleControl.SetPropDisplayString(DispID: Integer;
  1492.   const Value: string);
  1493. var
  1494.   I: Integer;
  1495.   Values: TStringList;
  1496.   V: Variant;
  1497. begin
  1498.   Values := TStringList.Create;
  1499.   try
  1500.     GetPropDisplayStrings(DispID, Values);
  1501.     for I := 0 to Values.Count - 1 do
  1502.       if AnsiCompareText(Value, Values[I]) = 0 then
  1503.       begin
  1504.         OleCheck(FPropBrowsing.GetPredefinedValue(DispID,
  1505.           Integer(Values.Objects[I]), V));
  1506.         SetProperty(DispID, TVarData(V));
  1507.         Exit;
  1508.       end;
  1509.   finally
  1510.     Values.Free;
  1511.   end;
  1512.   SetStringProp(DispID, Value);
  1513. end;
  1514.  
  1515. procedure TOleControl.SetProperty(Index: Integer; const Value: TVarData);
  1516. const
  1517.   DispIDArgs: Longint = DISPID_PROPERTYPUT;
  1518. var
  1519.   Status, InvKind: Integer;
  1520.   DispParams: TDispParams;
  1521.   ExcepInfo: TExcepInfo;
  1522. begin
  1523.   CreateControl;
  1524.   DispParams.rgvarg := @Value;
  1525.   DispParams.rgdispidNamedArgs := @DispIDArgs;
  1526.   DispParams.cArgs := 1;
  1527.   DispParams.cNamedArgs := 1;
  1528.   if Value.VType <> varDispatch then
  1529.     InvKind := DISPATCH_PROPERTYPUT else
  1530.     InvKind := DISPATCH_PROPERTYPUTREF;
  1531.   Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
  1532.     InvKind, DispParams, nil, @ExcepInfo, nil);
  1533.   if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
  1534. end;
  1535.  
  1536. procedure TOleControl.SetSingleProp(Index: Integer; Value: Single);
  1537. var
  1538.   Temp: TVarData;
  1539. begin
  1540.   Temp.VType := varSingle;
  1541.   Temp.VSingle := Value;
  1542.   SetProperty(Index, Temp);
  1543. end;
  1544.  
  1545. procedure TOleControl.SetSmallintProp(Index: Integer; Value: Smallint);
  1546. var
  1547.   Temp: TVarData;
  1548. begin
  1549.   Temp.VType := varSmallint;
  1550.   Temp.VSmallint := Value;
  1551.   SetProperty(Index, Temp);
  1552. end;
  1553.  
  1554. procedure TOleControl.SetStringProp(Index: Integer; const Value: string);
  1555. var
  1556.   Temp: TVarData;
  1557. begin
  1558.   Temp.VType := varOleStr;
  1559.   Temp.VOleStr := StringToOleStr(Value);
  1560.   try
  1561.     SetProperty(Index, Temp);
  1562.   finally
  1563.     SysFreeString(Temp.VOleStr);
  1564.   end;
  1565. end;
  1566.  
  1567. procedure TOleControl.SetUIActive(Active: Boolean);
  1568. var
  1569.   Form: TCustomForm;
  1570. begin
  1571.   Form := GetParentForm(Self);
  1572.   if Form <> nil then
  1573.     if Active then
  1574.     begin
  1575.       if (Form.ActiveOleControl <> nil) and
  1576.         (Form.ActiveOleControl <> Self) then
  1577.         Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  1578.       Form.ActiveOleControl := Self;
  1579.     end else
  1580.       if Form.ActiveOleControl = Self then Form.ActiveOleControl := nil;
  1581. end;
  1582.  
  1583. procedure TOleControl.SetVariantProp(Index: Integer; const Value: Variant);
  1584. begin
  1585.   if TVarData(Value).VType = varString then
  1586.     SetStringProp(Index, string(TVarData(Value).VString))
  1587.   else
  1588.     SetProperty(Index, TVarData(Value));
  1589. end;
  1590.  
  1591. procedure TOleControl.SetWideStringProp(Index: Integer; const Value: WideString);
  1592. var
  1593.   Temp: TVarData;
  1594. begin
  1595.   Temp.VType := varOleStr;
  1596.   Temp.VOleStr := PWideChar(Value);
  1597.   SetProperty(Index, Temp);
  1598. end;
  1599.  
  1600. procedure TOleControl.ShowAboutBox;
  1601. const
  1602.   DispInfo: array[0..7] of Byte = ($D8,$FD,$FF,$FF,$00,$01,$00,$00);
  1603. begin
  1604.   InvokeMethod(DispInfo, nil);
  1605. end;
  1606.  
  1607. procedure TOleControl.StandardEvent(DispID: TDispID; var Params: TDispParams);
  1608. type
  1609.   PVarDataList = ^TVarDataList;
  1610.   TVarDataList = array[0..3] of TVarData;
  1611. const
  1612.   ShiftMap: array[0..7] of TShiftState = (
  1613.     [],
  1614.     [ssShift],
  1615.     [ssCtrl],
  1616.     [ssShift, ssCtrl],
  1617.     [ssAlt],
  1618.     [ssShift, ssAlt],
  1619.     [ssCtrl, ssAlt],
  1620.     [ssShift, ssCtrl, ssAlt]);
  1621.   MouseMap: array[0..7] of TShiftState = (
  1622.     [],
  1623.     [ssLeft],
  1624.     [ssRight],
  1625.     [ssLeft, ssRight],
  1626.     [ssMiddle],
  1627.     [ssLeft, ssMiddle],
  1628.     [ssRight, ssMiddle],
  1629.     [ssLeft, ssRight, ssMiddle]);
  1630.   ButtonMap: array[0..7] of TMouseButton = (
  1631.     mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft);
  1632. var
  1633.   Args: PVarDataList;
  1634.   Shift: TShiftState;
  1635.   Button: TMouseButton;
  1636.   X, Y: Integer;
  1637. begin
  1638.   Args := PVarDataList(Params.rgvarg);
  1639.   try
  1640.     case DispID of
  1641.       DISPID_CLICK:
  1642.         Click;
  1643.       DISPID_DBLCLICK:
  1644.         DblClick;
  1645.       DISPID_KEYDOWN:
  1646.         KeyDown(Word(Args^[1].VPointer^), ShiftMap[Args^[0].VInteger and 7]);
  1647.       DISPID_KEYPRESS:
  1648.         KeyPress(Char(Args^[0].VPointer^));
  1649.       DISPID_KEYUP:
  1650.         KeyUp(Word(Args^[1].VPointer^), ShiftMap[Args^[0].VInteger and 7]);
  1651.       DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP:
  1652.         begin
  1653.           Button := ButtonMap[Args^[3].VInteger and 7];
  1654.           Shift := ShiftMap[Args^[2].VInteger and 7] +
  1655.             MouseMap[Args^[3].VInteger and 7];
  1656.           X := Args^[1].VInteger;
  1657.           Y := Args^[0].VInteger;
  1658.           case DispID of
  1659.             DISPID_MOUSEDOWN:
  1660.               MouseDown(Button, Shift, X, Y);
  1661.             DISPID_MOUSEMOVE:
  1662.               MouseMove(Shift, X, Y);
  1663.             DISPID_MOUSEUP:
  1664.               MouseUp(Button, Shift, X, Y);
  1665.           end;
  1666.         end;
  1667.     end;
  1668.   except
  1669.     Application.HandleException(Self);
  1670.   end;
  1671. end;
  1672.  
  1673. procedure TOleControl.WndProc(var Message: TMessage);
  1674. var
  1675.   WinMsg: TMsg;
  1676. begin
  1677.   if (Message.Msg >= CN_BASE + WM_KEYFIRST) and
  1678.     (Message.Msg <= CN_BASE + WM_KEYLAST) and
  1679.     (FOleInPlaceActiveObject <> nil) then
  1680.   begin
  1681.     WinMsg.HWnd := Handle;
  1682.     WinMsg.Message := Message.Msg - CN_BASE;
  1683.     WinMsg.WParam := Message.WParam;
  1684.     WinMsg.LParam := Message.LParam;
  1685.     WinMsg.Time := GetMessageTime;
  1686.     WinMsg.Pt.X := $115DE1F1;
  1687.     WinMsg.Pt.Y := $115DE1F1;
  1688.     if FOleInPlaceActiveObject.TranslateAccelerator(WinMsg) = S_OK then
  1689.     begin
  1690.       Message.Result := 1;
  1691.       Exit;
  1692.     end;
  1693.   end;
  1694.   inherited WndProc(Message);
  1695. end;
  1696.  
  1697. procedure TOleControl.WriteData(Stream: TStream);
  1698. var
  1699.   StorageExists: Boolean;
  1700.   Buffer: Pointer;
  1701. begin
  1702.   StorageExists := FObjectData <> 0;
  1703.   if not StorageExists then CreateStorage;
  1704.   try
  1705.     Buffer := GlobalLock(FObjectData);
  1706.     try
  1707.       Stream.Write(Buffer^, GlobalSize(FObjectData));
  1708.     finally
  1709.       GlobalUnlock(FObjectData);
  1710.     end;
  1711.   finally
  1712.     if not StorageExists then DestroyStorage;
  1713.   end;
  1714. end;
  1715.  
  1716. procedure TOleControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  1717. begin
  1718.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  1719.     DefaultHandler(Message) else
  1720.     inherited;
  1721. end;
  1722.  
  1723. procedure TOleControl.WMPaint(var Message: TWMPaint);
  1724. var
  1725.   DC: HDC;
  1726.   PS: TPaintStruct;
  1727. begin
  1728.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
  1729.   begin
  1730.     DC := Message.DC;
  1731.     if DC = 0 then DC := BeginPaint(Handle, PS);
  1732.     OleDraw(FOleObject, DVASPECT_CONTENT, DC, ClientRect);
  1733.     if Message.DC = 0 then EndPaint(Handle, PS);
  1734.   end else
  1735.     inherited;
  1736. end;
  1737.  
  1738. procedure TOleControl.CMDocWindowActivate(var Message: TMessage);
  1739. var
  1740.   Form: TCustomForm;
  1741.   F: TForm;
  1742. begin
  1743.   Form := GetParentForm(Self);
  1744.   F := nil;
  1745.   if Form is TForm then F := TForm(Form);
  1746.   if (F <> nil) and (F.FormStyle = fsMDIChild) then
  1747.   begin
  1748.     FOleInPlaceActiveObject.OnDocWindowActivate(LongBool(Message.WParam));
  1749.     if Message.WParam = 0 then SetMenu(0, 0, 0);
  1750.   end;
  1751. end;
  1752.  
  1753. procedure TOleControl.CMColorChanged(var Message: TMessage);
  1754. begin
  1755.   inherited;
  1756.   if (FControlData^.Flags and cfBackColor <> 0) and not FUpdatingColor and
  1757.     HandleAllocated then
  1758.   begin
  1759.     FUpdatingColor := True;
  1760.     try
  1761.       SetColorProp(DISPID_BACKCOLOR, Color);
  1762.     finally
  1763.       FUpdatingColor := False;
  1764.     end;
  1765.   end;
  1766. end;
  1767.  
  1768. procedure TOleControl.CMEnabledChanged(var Message: TMessage);
  1769. begin
  1770.   inherited;
  1771.   if (FControlData^.Flags and cfEnabled <> 0) and not FUpdatingEnabled and
  1772.     HandleAllocated then
  1773.   begin
  1774.     FUpdatingEnabled := True;
  1775.     try
  1776.       SetWordBoolProp(DISPID_ENABLED, Enabled);
  1777.     finally
  1778.       FUpdatingEnabled := False;
  1779.     end;
  1780.   end;
  1781. end;
  1782.  
  1783. procedure TOleControl.CMFontChanged(var Message: TMessage);
  1784. begin
  1785.   inherited;
  1786.   if (FControlData^.Flags and (cfForeColor or cfFont) <> 0) and
  1787.     not FUpdatingFont and HandleAllocated then
  1788.   begin
  1789.     FUpdatingFont := True;
  1790.     try
  1791.       if FControlData^.Flags and cfForeColor <> 0 then
  1792.         SetIntegerProp(DISPID_FORECOLOR, Font.Color);
  1793.       if FControlData^.Flags and cfFont <> 0 then
  1794.         SetVariantProp(DISPID_FONT, FontToOleFont(Font));
  1795.     finally
  1796.       FUpdatingFont := False;
  1797.     end;
  1798.   end;
  1799. end;
  1800.  
  1801. procedure TOleControl.CMDialogKey(var Message: TMessage);
  1802. var
  1803.   Info: TControlInfo;
  1804.   Msg: TMsg;
  1805.   Cmd: Word;
  1806. begin
  1807.   if CanFocus then
  1808.   begin
  1809.     Info.cb := SizeOf(Info);
  1810.     if (FOleControl.GetControlInfo(Info) = S_OK) and (Info.cAccel <> 0) then
  1811.     begin
  1812.       FillChar(Msg, SizeOf(Msg), 0);
  1813.       Msg.hwnd := Handle;
  1814.       Msg.message := WM_KEYDOWN;
  1815.       Msg.wParam := Message.WParam;
  1816.       Msg.lParam := Message.LParam;
  1817.       if IsAccelerator(Info.hAccel, Info.cAccel, @Msg, Cmd) then
  1818.       begin
  1819.         FOleControl.OnMnemonic(@Msg);
  1820.         Message.Result := 1;
  1821.         Exit;
  1822.       end;
  1823.     end;
  1824.   end;
  1825.   inherited;
  1826. end;
  1827.  
  1828. procedure TOleControl.CMUIActivate(var Message: TMessage);
  1829. var
  1830.   F: TCustomForm;
  1831. begin
  1832.   F := GetParentForm(Self);
  1833.   if (F = nil) or (F.ActiveOleControl <> Self) then
  1834.     FOleObject.DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0,
  1835.       GetParentHandle, BoundsRect);
  1836. end;
  1837.  
  1838. procedure TOleControl.CMUIDeactivate(var Message: TMessage);
  1839. var
  1840.   F: TCustomForm;
  1841. begin
  1842.   F := GetParentForm(Self);
  1843.   if (F = nil) or (F.ActiveOleControl = Self) then
  1844.     FOleInPlaceObject.UIDeactivate;
  1845. end;
  1846.  
  1847. { TOleControl.IUnknown }
  1848.  
  1849. function TOleControl.QueryInterface(const IID: TGUID; out Obj): HResult;
  1850. begin
  1851.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  1852. end;
  1853.  
  1854. function TOleControl._AddRef: Integer;
  1855. begin
  1856.   Inc(FRefCount);
  1857.   Result := FRefCount;
  1858. end;
  1859.  
  1860. function TOleControl._Release: Integer;
  1861. begin
  1862.   Dec(FRefCount);
  1863.   Result := FRefCount;
  1864. end;
  1865.  
  1866. { TOleControl.IOleClientSite }
  1867.  
  1868. function TOleControl.SaveObject: HResult;
  1869. begin
  1870.   Result := S_OK;
  1871. end;
  1872.  
  1873. function TOleControl.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  1874.   out mk: IMoniker): HResult;
  1875. begin
  1876.   Result := E_NOTIMPL;
  1877. end;
  1878.  
  1879. function TOleControl.GetContainer(out container: IOleContainer): HResult;
  1880. begin
  1881.   Result := E_NOINTERFACE;
  1882. end;
  1883.  
  1884. function TOleControl.ShowObject: HResult;
  1885. begin
  1886.   HookControlWndProc;
  1887.   Result := S_OK;
  1888. end;
  1889.  
  1890. function TOleControl.OnShowWindow(fShow: BOOL): HResult;
  1891. begin
  1892.   Result := S_OK;
  1893. end;
  1894.  
  1895. function TOleControl.RequestNewObjectLayout: HResult;
  1896. begin
  1897.   Result := E_NOTIMPL;
  1898. end;
  1899.  
  1900. { TOleControl.IOleControlSite }
  1901.  
  1902. function TOleControl.OnControlInfoChanged: HResult;
  1903. begin
  1904.   Result := E_NOTIMPL;
  1905. end;
  1906.  
  1907. function TOleControl.LockInPlaceActive(fLock: BOOL): HResult;
  1908. begin
  1909.   Result := E_NOTIMPL;
  1910. end;
  1911.  
  1912. function TOleControl.GetExtendedControl(out disp: IDispatch): HResult;
  1913. begin
  1914.   Result := E_NOTIMPL;
  1915. end;
  1916.  
  1917. function TOleControl.TransformCoords(var ptlHimetric: TPoint;
  1918.   var ptfContainer: TPointF; flags: Longint): HResult;
  1919. begin
  1920.   if flags and XFORMCOORDS_HIMETRICTOCONTAINER <> 0 then
  1921.   begin
  1922.     ptfContainer.X := MulDiv(ptlHimetric.X, Screen.PixelsPerInch, 2540);
  1923.     ptfContainer.Y := MulDiv(ptlHimetric.Y, Screen.PixelsPerInch, 2540);
  1924.   end else
  1925.   begin
  1926.     ptlHimetric.X := Round(ptfContainer.X * 2540 / Screen.PixelsPerInch);
  1927.     ptlHimetric.Y := Round(ptfContainer.Y * 2540 / Screen.PixelsPerInch);
  1928.   end;
  1929.   Result := S_OK;
  1930. end;
  1931.  
  1932. function TOleControl.OleControlSite_TranslateAccelerator(
  1933.   msg: PMsg; grfModifiers: Longint): HResult;
  1934. begin
  1935.   Result := E_NOTIMPL;
  1936. end;
  1937.  
  1938. function TOleControl.OnFocus(fGotFocus: BOOL): HResult;
  1939. begin
  1940.   Result := E_NOTIMPL;
  1941. end;
  1942.  
  1943. function TOleControl.ShowPropertyFrame: HResult;
  1944. begin
  1945.   Result := E_NOTIMPL;
  1946. end;
  1947.  
  1948. { TOleControl.IOleWindow }
  1949.  
  1950. function TOleControl.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  1951. begin
  1952.   Result := S_OK;
  1953. end;
  1954.  
  1955. { TOleControl.IOleInPlaceSite }
  1956.  
  1957. function TOleControl.OleInPlaceSite_GetWindow(out wnd: HWnd): HResult;
  1958. begin
  1959.   Result := S_OK;
  1960.   wnd := GetParentHandle;
  1961.   if wnd = 0 then Result := E_FAIL;
  1962. end;
  1963.  
  1964. function TOleControl.CanInPlaceActivate: HResult;
  1965. begin
  1966.   Result := S_OK;
  1967. end;
  1968.  
  1969. function TOleControl.OnInPlaceActivate: HResult;
  1970. begin
  1971.   FOleObject.QueryInterface(IOleInPlaceObject, FOleInPlaceObject);
  1972.   FOleObject.QueryInterface(IOleInPlaceActiveObject, FOleInPlaceActiveObject);
  1973.   Result := S_OK;
  1974. end;
  1975.  
  1976. function TOleControl.OnUIActivate: HResult;
  1977. begin
  1978.   SetUIActive(True);
  1979.   Result := S_OK;
  1980. end;
  1981.  
  1982. function TOleControl.GetWindowContext(out frame: IOleInPlaceFrame;
  1983.   out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
  1984.   out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
  1985. begin
  1986.   frame := Self;
  1987.   doc := nil;
  1988.   rcPosRect := BoundsRect;
  1989.   SetRect(rcClipRect, 0, 0, 32767, 32767);
  1990.   with frameInfo do
  1991.   begin
  1992.     fMDIApp := False;
  1993.     hWndFrame := GetTopParentHandle;
  1994.     hAccel := 0;
  1995.     cAccelEntries := 0;
  1996.   end;
  1997.   Result := S_OK;
  1998. end;
  1999.  
  2000. function TOleControl.Scroll(scrollExtent: TPoint): HResult;
  2001. begin
  2002.   Result := E_NOTIMPL;
  2003. end;
  2004.  
  2005. function TOleControl.OnUIDeactivate(fUndoable: BOOL): HResult;
  2006. begin
  2007.   SetMenu(0, 0, 0);
  2008.   SetUIActive(False);
  2009.   Result := S_OK;
  2010. end;
  2011.  
  2012. function TOleControl.OnInPlaceDeactivate: HResult;
  2013. begin
  2014.   FOleInPlaceActiveObject := nil;
  2015.   FOleInPlaceObject := nil;
  2016.   Result := S_OK;
  2017. end;
  2018.  
  2019. function TOleControl.DiscardUndoState: HResult;
  2020. begin
  2021.   Result := E_NOTIMPL;
  2022. end;
  2023.  
  2024. function TOleControl.DeactivateAndUndo: HResult;
  2025. begin
  2026.   FOleInPlaceObject.UIDeactivate;
  2027.   Result := S_OK;
  2028. end;
  2029.  
  2030. function TOleControl.OnPosRectChange(const rcPosRect: TRect): HResult;
  2031. begin
  2032.   FOleInPlaceObject.SetObjectRects(rcPosRect, Rect(0, 0, 32767, 32767));
  2033.   Result := S_OK;
  2034. end;
  2035.  
  2036. { TOleControl.IOleInPlaceUIWindow }
  2037.  
  2038. function TOleControl.GetBorder(out rectBorder: TRect): HResult;
  2039. begin
  2040.   Result := INPLACE_E_NOTOOLSPACE;
  2041. end;
  2042.  
  2043. function TOleControl.RequestBorderSpace(const borderwidths: TRect): HResult;
  2044. begin
  2045.   Result := INPLACE_E_NOTOOLSPACE;
  2046. end;
  2047.  
  2048. function TOleControl.SetBorderSpace(pborderwidths: PRect): HResult;
  2049. begin
  2050.   Result := E_NOTIMPL;
  2051. end;
  2052.  
  2053. function TOleControl.SetActiveObject(const activeObject: IOleInPlaceActiveObject;
  2054.   pszObjName: POleStr): HResult;
  2055. begin
  2056.   Result := S_OK;
  2057. end;
  2058.  
  2059. { TOleControl.IOleInPlaceFrame }
  2060.  
  2061. function TOleControl.OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult;
  2062. begin
  2063.   wnd := GetTopParentHandle;
  2064.   Result := S_OK;
  2065. end;
  2066.  
  2067. function TOleControl.InsertMenus(hmenuShared: HMenu;
  2068.   var menuWidths: TOleMenuGroupWidths): HResult;
  2069. var
  2070.   Menu: TMainMenu;
  2071. begin
  2072.   Menu := GetMainMenu;
  2073.   if Menu <> nil then
  2074.     Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);
  2075.   Result := S_OK;
  2076. end;
  2077.  
  2078. function TOleControl.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  2079.   hwndActiveObject: HWnd): HResult;
  2080. var
  2081.   Menu: TMainMenu;
  2082. begin
  2083.   Menu := GetMainMenu;
  2084.   Result := S_OK;
  2085.   if Menu <> nil then
  2086.   begin
  2087.     Menu.SetOle2MenuHandle(hmenuShared);
  2088.     Result := OleSetMenuDescriptor(holemenu, Menu.WindowHandle,
  2089.       hwndActiveObject, nil, nil);
  2090.   end;
  2091. end;
  2092.  
  2093. function TOleControl.RemoveMenus(hmenuShared: HMenu): HResult;
  2094. begin
  2095.   while GetMenuItemCount(hmenuShared) > 0 do
  2096.     RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
  2097.   Result := S_OK;
  2098. end;
  2099.  
  2100. function TOleControl.SetStatusText(pszStatusText: POleStr): HResult;
  2101. begin
  2102.   Result := S_OK;
  2103. end;
  2104.  
  2105. function TOleControl.EnableModeless(fEnable: BOOL): HResult;
  2106. begin
  2107.   Result := S_OK;
  2108. end;
  2109.  
  2110. function TOleControl.OleInPlaceFrame_TranslateAccelerator(
  2111.   var msg: TMsg; wID: Word): HResult;
  2112. begin
  2113.   Result := S_FALSE;
  2114. end;
  2115.  
  2116. { TOleControl.IDispatch }
  2117.  
  2118. function TOleControl.GetTypeInfoCount(out Count: Integer): HResult;
  2119. begin
  2120.   Count := 0;
  2121.   Result := S_OK;
  2122. end;
  2123.  
  2124. function TOleControl.GetTypeInfo(Index, LocaleID: Integer;
  2125.   out TypeInfo): HResult;
  2126. begin
  2127.   Pointer(TypeInfo) := nil;
  2128.   Result := E_NOTIMPL;
  2129. end;
  2130.  
  2131. function TOleControl.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  2132.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  2133. begin
  2134.   Result := E_NOTIMPL;
  2135. end;
  2136.  
  2137. function TOleControl.Invoke(DispID: Integer; const IID: TGUID;
  2138.   LocaleID: Integer; Flags: Word; var Params;
  2139.   VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  2140. begin
  2141.   if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
  2142.   begin
  2143.     Result := S_OK;
  2144.     case DispID of
  2145.       DISPID_AMBIENT_BACKCOLOR:
  2146.         PVariant(VarResult)^ := Color;
  2147.       DISPID_AMBIENT_DISPLAYNAME:
  2148.         PVariant(VarResult)^ := StringToVarOleStr(Name);
  2149.       DISPID_AMBIENT_FONT:
  2150.         if (Parent <> nil) and ParentFont then
  2151.           PVariant(VarResult)^ := FontToOleFont(TOleControl(Parent).Font)
  2152.         else
  2153.           Result := DISP_E_MEMBERNOTFOUND;
  2154.       DISPID_AMBIENT_FORECOLOR:
  2155.         PVariant(VarResult)^ := Font.Color;
  2156.       DISPID_AMBIENT_LOCALEID:
  2157.         PVariant(VarResult)^ := GetUserDefaultLCID;
  2158.       DISPID_AMBIENT_MESSAGEREFLECT:
  2159.         PVariant(VarResult)^ := True;
  2160.       DISPID_AMBIENT_USERMODE:
  2161.         PVariant(VarResult)^ := not (csDesigning in ComponentState);
  2162.       DISPID_AMBIENT_UIDEAD:
  2163.         PVariant(VarResult)^ := csDesigning in ComponentState;
  2164.       DISPID_AMBIENT_SHOWGRABHANDLES:
  2165.         PVariant(VarResult)^ := False;
  2166.       DISPID_AMBIENT_SHOWHATCHING:
  2167.         PVariant(VarResult)^ := False;
  2168.       DISPID_AMBIENT_SUPPORTSMNEMONICS:
  2169.         PVariant(VarResult)^ := True;
  2170.       DISPID_AMBIENT_AUTOCLIP:
  2171.         PVariant(VarResult)^ := True;
  2172.     else
  2173.       Result := DISP_E_MEMBERNOTFOUND;
  2174.     end;
  2175.   end else
  2176.     Result := DISP_E_MEMBERNOTFOUND;
  2177. end;
  2178.  
  2179. { TOleControl.IPropertyNotifySink }
  2180.  
  2181. function TOleControl.OnChanged(dispid: TDispID): HResult;
  2182. begin
  2183.   case dispid of
  2184.     DISPID_BACKCOLOR:
  2185.       if not FUpdatingColor then
  2186.       begin
  2187.         FUpdatingColor := True;
  2188.         try
  2189.           Color := GetIntegerProp(DISPID_BACKCOLOR);
  2190.         finally
  2191.           FUpdatingColor := False;
  2192.         end;
  2193.       end;
  2194.     DISPID_ENABLED:
  2195.       if not FUpdatingEnabled then
  2196.       begin
  2197.         FUpdatingEnabled := True;
  2198.         try
  2199.           Enabled := GetWordBoolProp(DISPID_ENABLED);
  2200.         finally
  2201.           FUpdatingEnabled := False;
  2202.         end;
  2203.       end;
  2204.     DISPID_FONT:
  2205.       if not FUpdatingFont then
  2206.       begin
  2207.         FUpdatingFont := True;
  2208.         try
  2209.           OleFontToFont(GetVariantProp(DISPID_FONT), Font);
  2210.         finally
  2211.           FUpdatingFont := False;
  2212.         end;
  2213.       end;
  2214.     DISPID_FORECOLOR:
  2215.       if not FUpdatingFont then
  2216.       begin
  2217.         FUpdatingFont := True;
  2218.         try
  2219.           Font.Color := GetIntegerProp(DISPID_FORECOLOR);
  2220.         finally
  2221.           FUpdatingFont := False;
  2222.         end;
  2223.       end;
  2224.   end;
  2225.   Result := S_OK;
  2226. end;
  2227.  
  2228. function TOleControl.OnRequestEdit(dispid: TDispID): HResult;
  2229. begin
  2230.   Result := S_OK;
  2231. end;
  2232.  
  2233. { TOleControl.ISimpleFrameSite }
  2234.  
  2235. function TOleControl.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  2236.   out res: Integer; out Cookie: Longint): HResult;
  2237. begin
  2238.   Result := S_OK;
  2239. end;
  2240.  
  2241. function TOleControl.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  2242.   out res: Integer; Cookie: Longint): HResult;
  2243. begin
  2244.   Result := S_OK;
  2245. end;
  2246.  
  2247. end.
  2248.